CEOI 1997, Polonia
Problema: DOM Dominouri

Un domino este o piesa a carui fata este impartita in doua patrate, un patrat 
putand avea intre 0 si 6 puncte. Pe masa este asezata o linie de dominouri 
(ca in figura):

	-----	-----	-----	-----
	| 6 |	| 1 |	| 1 |	| 1 |
	----	----	-----	-----
	| 1 |	| 5 |	| 3 |	| 2 |
	-----	-----	-----	-----
Numarul de puncte de pe linia superioara este 6+1+1+1=9, iar cel de pe linia 
inferioara este 1+5+3+2=11. Distanta dintre linia superioara si cea inferioara 
este 2.
S-a definit distanta ca fiind valoarea absoluta a diferentei dintre cele doua 
sume.
Fiecare domino poate fi intors cu 180 de grade (pastrand fata).
Care este cel mai mic numar de intoarceri necesar pentru a minimiza distanta 
dintre linia superioara si cea inferioar ? 
In figura de sus este suficient sa fie intors ultimul domino pentru a micsora 
distanta la 0. In acest caz raspunsul este 1.

Problema
Scrieti un program care: 
- citeste numarul de dominouri si descrierea lor din fisierul text DOM.IN, 
- calculeaza cel mai mic numar de intoarceri necesar minimizarii distantei dintre 
linia superioara si cea inferioara,
- scrie rezultatul in fisierul DOM.OUT.

Intrare
Prima linie a fisierului DOM.IN contine un numar intreg n, 1<n<1000. Acesta este 
numarul dominourilor de pe masa, asezate pe o singura linie.

Fiecare din urmatoarele n linii contine doua numere intregi a,b (0<a,b<6),
separate printr-un spatiu. Numerele a si b scrise pe linia i+1 a fisierului de 
intrare (1<i<n) reprezinta numrul de puncte de pe linia superioara, respectiv 
inferioar ale celui de al i-lea domino de pe tabla.

Iesire

Programul trebuie sa scrie un numar intreg pe prima linie a fisierului DOM.OUT;
el reprezinta numarul de intoarceri necesare pentru a minimiza distanta dintre
linia de sus si cea de jos.

Exemplu
Pentru fisierul DOM.IN:
4
6 1
1 5
1 3
1 2
solutia corecta este:
1

S-au dat 10 teste, fiecare cotat cu cate 4 puncte.
Timp limita per test: 2 sec.
=================================

Solutia 1 (Angel Proorocu Ploiesti):
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+}
{$M 16384,0,655360}

program DominoStatic;

   uses Crt,Dos;

   var
       c:array[-6000..6000]of word;
       f:text;
       n:integer;

procedure Afiseaza;
   var h,m,sec,sut:word;
   begin
     gettime(h,m,sec,sut);
     writeln(h,' ',m,' ',sec,' ',sut);
   end;

procedure ReadData;
   var i,j,k,l,li,ls,jj,ss,s,p,dif:integer;
   begin
    assign(f,'dom.in');
    reset(f);
    readln(f,n);
    c[0]:=1;
    li:=0;
    ls:=0;
    ss:=0;
    jj:=0;
    for l:=1 to n do
     begin
       readln(f,s,j);
       ss:=ss+s;
       jj:=jj+j;
       p:=j-s;
       if p<0 then
       begin
       for i:=li to ls do if c[i]>0 then if (c[i+p]>c[i]+1)or(c[i+p]=0) then
        begin
         c[i+p]:=c[i]+1;
         if i+p<li then li:=i+p;
        end;
       end;
       if p>0 then
       begin
       for i:=ls downto li do if c[i]>0 then
       if (c[i+p]>c[i]+1)or(c[i+p]=0) then
        begin
         c[i+p]:=c[i]+1;
         if i+p>ls then ls:=i+p;
        end;
       end;
     end;
     close(f);
     dif:=(jj-ss)div 2;
     assign(f,'dom.out');
     rewrite(F);
     if c[dif]>0 then
      begin
       writeln(f,c[dif]-1);
       afiseaza;
       close(f);
       halt;
      end;
     i:=dif-1; j:=dif+1;
     while (i>=li)or(j<=ls) do
      begin
       if (c[i]>0) then if (c[j]=0)or(c[j]>c[i]) then
        begin
         writeln(f,c[i]-1);
         afiseaza;
         close(f);
         halt;
        end;
       if c[j]>0 then
        begin
         writeln(f,c[j]-1);
         afiseaza;
         close(F);
         halt;
        end;
       i:=i-1;
       j:=j+1;
      end;
    writeln(f,'dcvkojcvs');
    close(F);
   end;

begin
  afiseaza;
  ReadData;
end.
-------------------------------

Solutia 2 (Bogdan Batog - Bucuresti)
const max=1000;
type
    vec = array[-6..6] of integer;
    rec = record
            nr          :integer;
            s           :vec;
          end;
    dat = array[0..max] of rec;
var
   fil                          :text;
   n,i,j,d,f,a,b,t1,t2,m        :longint;
   tmp                          :integer;
   v                            :vec;
   p                            :array[0..50] of ^dat;

Procedure Get(m:longint;var i,j:longint);
begin
     i:=m div max;
     j:=m mod max;
     if p[i]=nil then
     begin
          new(p[i]);
          fillchar(p[i]^,sizeof(p[i]^),0);
     end;
end;

begin
     assign(fil,'DOM.IN');
     reset(fil);
     readln(fil,n);
     for i:=-6 to 6 do v[i]:=0;
     for i:=1 to n do
     begin
          readln(fil,a,b);
          inc(v[a-b]);
          d:=d+a-b;
     end;
     close(fil);
     if d<0 then
     begin
          D:=-D;
          for i:=-6 to -1 do
          begin
               tmp:=v[i];
               v[i]:=v[-i];
               v[-i]:=tmp
          end;
     end;
     for i:=0 to 50 do p[i]:=nil;
     for f:=1 to D+100 do
     begin
          Get(f,i,j);
          p[i]^[j].nr:=-1;
     end;
     p[0]^[0].nr:=0;
     p[0]^[0].s:=v;
     f:=0;
     repeat
           Get(f,i,j);
           for a:=-6 to 6 do
            if (p[i]^[j].s[a]>0) and (a<>0) then
             if (f+2*a>0) and (f+2*a<=D+12) then
             begin
                Get(f+2*a,t1,t2);
                if (p[t1]^[t2].nr=-1) or (p[t1]^[t2].nr>p[i]^[j].nr+1) then
                begin
                     p[t1]^[t2]:=p[i]^[j];
                     inc(p[t1]^[t2].nr);
                     dec(p[t1]^[t2].s[a]);
                end;
             end;
           inc(f);
           Get(f,i,j);
           while p[i]^[j].nr=-1 do begin inc(f); Get(f,i,j) end
     until (f>d+12) or (f=maxlongint);
     f:=d;
     Get(f,i,j);
     while (p[i]^[j].nr=-1) do
     begin
          dec(f);
          Get(f,i,j);
     end;
     m:=F;
     A:=p[i]^[j].nr;
     f:=d;
     Get(f,i,j);
     while (p[i]^[j].nr=-1) and (f<d+12) do
     begin
          inc(f);
          Get(f,i,j);
     end;
     if p[i]^[j].nr<>-1 then
     begin
      if (F-D<D-M) then A:=p[i]^[j].nr else
       if F-D=D-M then
        if p[i]^[j].nr<A then A:=p[i]^[j].nr;
     end;
     assign(fil,'DOM.OUT');
     rewrite(fil);
     writeln(fil,A);
     close(Fil)
end.
---------------------------------

Solutia 3 (Cristian Cadar - Bucuresti)
uses crt,dos;
type
    ref=^reco;
    reco=
         record
               inf:integer;
               urm:ref;
         end;
var
   d:array[1..1000] of integer;
   a:array[-6000..6000] of byte;
   t:array[-6000..6000] of integer;
   p,q,ic,sc:ref;
   f:text;
   st:string;
   min,si,sj,i,j,k,n:integer;

procedure timp;
var
   hh,mm,ss,sss:word;
begin
     gettime(hh,mm,ss,sss);
     writeln(ss,':',sss);
end;

procedure citire;
begin
     clrscr;
     write('Fisier intrare:');
     readln(st);
     assign(f,st);
     reset(f);
     readln(f,n);
     si:=0;sj:=0;
     for k:=1 to n do
         begin
              readln(f,i,j);
              d[k]:=(i-j)*2;
              si:=si+i;
              sj:=sj+j;
         end;
     close(f);
end;

procedure succesori;
var
   k:integer;
begin
     if abs(min)>abs(ic^.inf)
        then min:=ic^.inf;
     for k:=1 to n do
         if t[ic^.inf+d[k]]>t[ic^.inf]+1
            then
                begin
                     t[ic^.inf+d[k]]:=t[ic^.inf]+1;
                     new(p);
                     p^.inf:=ic^.inf+d[k];
                     p^.urm:=nil;
                     sc^.urm:=p;
                     sc:=p;
                end;
end;

procedure prelucrare;
begin
     fillchar(a,sizeof(a),0);
     for i:=-6000 to 6000 do
         t[i]:=maxint;
     min:=sj-si;
     t[sj-si]:=0;
     new(ic);
     sc:=ic;
     ic^.inf:=sj-si;
     ic^.urm:=nil;
     while ic<>nil do
        begin
             succesori;
             ic:=ic^.urm;
        end;
     writeln(t[min]);
end;

begin
     citire;
     timp;
     prelucrare;
     timp;
end.
-------------------------------

Solutia 4 (Tudor Leu - Focsani)
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+,Y+}
{$M 16384,0,655360}

const ni='dom.in';
      no='dom.out';
var a:array[-6000..6000] of word;
    xm,xp:array[1..6] of word;
    i,j,k,l,n,d,p:integer;
procedure citeste;
begin
     assign(input,ni);reset(input);
     readln(n);
     d:=0;
     for i:=1 to 6 do begin xm[i]:=0;xp[i]:=0 end;
     for i:=1 to n do begin
        readln(j,k);
        d:=d+j-k;
        if j-k>0 then xp[j-k]:=xp[j-k]+1
                 else xm[k-j]:=xm[k-j]+1;
     end;
end;
procedure rezolva;
begin
     for i:=-6000 to 6000 do a[i]:=30000;
     k:=d;l:=d;a[d]:=0;
     for i:=1 to 6 do
        for j:=k to l do
           if a[j]<30000 then begin
                for p:=1 to xp[i] do
                   if a[j-2*p*i]>a[j]+p then begin a[j-2*p*i]:=a[j]+p;
                                                   if k>j-2*p*i then
                                                        k:=j-2*p*i;
                                             end;
                for p:=1 to xm[i] do
                   if a[j+2*p*i]>a[j]+p then begin a[j+2*p*i]:=a[j]+p;
                                                   if l<j+2*p*i then
                                                        l:=j+2*p*i;
                                             end;
                              end;
end;
procedure scrie;
begin
     assign(output,no);rewrite(output);
     i:=0;
     while not ((a[i]<30000) or (a[-i]<30000)) do i:=i+1;
     if a[i]<a[-i] then writeln(a[i])
                   else writeln(a[-i]);
end;
begin
     citeste;
     rezolva;
     scrie
end.
--------------------------------

Solutia 5 (Valentin Gheorghita - Ploiesti)
program dominoes;
type sir=array[-6010..6010] of boolean;
var cat,cattmp:array[-6010..6010] of integer;
    obt,obttmp:^sir;
    n:integer;
    d:array[1..1000] of integer;

procedure tiparire;
 var i,min:integer;
     f:text;
 begin
  for i:=0 to 30 do
   if obt^[i] or obt^[-i] then begin
                                min:=maxint;
                                if obt^[i] and (min>cat[i]) then min:=cat[i];
                                if obt^[-i] and (min>cat[-i]) then min:=cat[-i];
                                assign(f,'dom.out');
                                rewrite(f);
                                writeln(f,min);
                                close(f);
                                halt;
                               end;
 end;

procedure citire;
 var f:text;
     i,x,y:integer;
 begin
  assign(f,'dom.in');
  reset(f);
  readln(f,n);
  for i:=1 to n do
   begin
    readln(f,x,y);
    d[i]:=x-y;
   end;
  close(f);
 end;

procedure calcul;
 var sc,pz,i,j,k:integer;
     nr,up,down:array[1..6] of integer;
 begin
  new(obt);
  new(obttmp);
  for i:=0 to 6 do begin down[i]:=0; up[i]:=0; end;
  for i:=1 to n do
   begin
    if d[i]<0 then dec(down[abs(d[i])]);
    if d[i]>0 then inc(up[abs(d[i])]);
   end;
  for i:=1 to 6 do nr[i]:=abs(down[i])+abs(up[i]);
  for i:=-6000 to 6000 do obt^[i]:=false;
  obt^[0]:=true;
  cat[0]:=0;
  for i:=1 to 6 do
   if (up[i]<>0) or (down[i]<>0) then
   begin
    for j:=-6000 to 6000 do obttmp^[j]:=false;
    for j:=-6000 to 6000 do
     if obt^[j] then
      for k:=0 to nr[i] do
       begin
        pz:=j+k*i-i*(nr[i]-k);
        sc:=cat[j]+abs(k-up[i]);
        if not(obttmp^[pz]) then begin
                                  obttmp^[pz]:=true;
                                  cattmp[pz]:=sc;
                                 end
                            else if cattmp[pz]>sc then cattmp[pz]:=sc;
      end;
    cat:=cattmp;
    obt^:=obttmp^;
   end;
 end;


begin
 citire;
 calcul;
 tiparire;
end.
-------------------------------

Solutia 6 (Adrian carcu - Bistrita Nasaud)
{$Q-,R-,S-,N+,E-,G+}
var fis:text;
    a:array[1..1000] of integer;
    x,xx:array[-6006..6006] of word;
    i,j,k,n,m,min,max,mmin,mmax,sum,vp,vm:integer;
    timer:longint absolute 0:$46c;
    start:longint;
begin
   start:=timer;
   assign(fis,'dom.in'); reset(fis);
   readln(fis,n); m:=0;
   for k:=1 to n do begin
      readln(fis,i,j);
      if i<>j then begin inc(m); a[m]:=i-j; sum:=sum+i-j; end;
      end;
   close(fis); n:=m;
   x[0]:=0; min:=0; max:=0;
   for i:=1 to n do begin
      mmin:=min; mmax:=max;
      if i and 63=63 then write(i,#13);
      fillchar(xx[min-6],(max-min+13) shl 1,255);
      for j:=min to max do if x[j]<65535 then begin
         vp:=j+a[i]; vm:=j-a[i];
         if xx[vp]>x[j] then begin
            xx[vp]:=x[j];
            if vp<mmin then mmin:=vp else
            if vp>mmax then mmax:=vp;
            end;
         if xx[vm]>x[j]+1 then begin
            xx[vm]:=x[j]+1;
            if vm<mmin then mmin:=vm else
            if vm>mmax then mmax:=vm;
            end;
         end;
      min:=mmin; max:=mmax;
      move(xx[min],x[min],(max-min+1) shl 1);
      end;
   assign(fis,'dom.out'); rewrite(fis);
   for i:=0 to 6000 do if (x[i]<65535)or(x[-i]<65535) then begin
      if x[i]<x[-i] then writeln(fis,i,' ',x[i]) else writeln(fis,i,' ',x[-i]);
      break;
      end;
   close(fis);
   writeln((timer-start)/18.2:0:3,' secunde');
end.
--------------------------------

Solutia 7 (Virgil Serbanuta - Focsani)
const max=6000;
var valori:array[-6..6] of word;
    n,sup,inf:word;
    a:array[0..max] of word;
    i,j:shortint;

procedure citire;
var i,j:shortint;
    k:word;
begin
readln(n);
for i:=-6 to 6 do valori[i]:=0;
for k:=1 to n do
    begin
    readln(i,j);
    sup:=sup+i;
    inf:=inf+j;
    inc(valori[i-j]);
    end;
a[inf]:=1;
end;

procedure obtp(t:byte);
var i,j,fo,ffo,ff:word;
    b,c,d,p:array[0..max] of word;
    xa,ya:byte;
    ss:word;
begin
fillchar(b,sizeof(b),0);
fillchar(c,sizeof(c),0);
fillchar(d,sizeof(d),0);
c[0]:=0;
for i:=0 to t-1 do
    begin
    fillchar(d,sizeof(d),0);
    j:=i;
    xa:=1;
    ya:=0;
    while (j<=max) do begin
          if xa>ya then
             if a[j]>0 then begin
                inc(ya);
                c[ya]:=a[j];
                p[ya]:=j;
                fo:=0;
                ffo:=0;
                inc(j,t);
                continue;
                end;
          if xa<=ya then begin
             inc(fo);
             if fo>valori[t] then
                begin
                inc(xa);
                if xa<=ya then begin
                   fo:=fo-d[xa];
                   ffo:=ffo-d[xa];
                   end;
                end;
             end;
          if xa<=ya then begin
             if a[j]=0
                then a[j]:=fo+c[ya]
                else begin
                     while (xa<=ya) and (a[j]<c[ya]+fo-ffo) do begin
                           ffo:=ffo-d[ya];
                           dec(ya);
                           end;
                     if ya<xa then begin
                        c[xa]:=a[j];
                        p[xa]:=j;
                        fo:=0;
                        ffo:=0;
                        ya:=xa;
                        end
                        else begin
                        inc(ya);
                        p[ya]:=j;
                        d[ya]:=(j-p[ya-1]) div t;
                        c[ya]:=a[j];
                        ffo:=ffo+d[ya];
                        end;
                     if a[j]>c[xa]+fo then a[j]:=c[xa]+fo;
                     end;
             end;
          inc(j,t);
          end;
    end;
end;

procedure obtn(t:shortint);
var i,j,fo,ffo,ff:integer;
    b,c,d,p:array[0..max] of word;
    xa,ya:byte;
    ss:word;
begin
fillchar(b,sizeof(b),0);
fillchar(c,sizeof(c),0);
fillchar(d,sizeof(d),0);
c[0]:=0;
for i:=0 to abs(t)-1 do
    begin
    fillchar(d,sizeof(d),0);
    j:=max-i;
    xa:=1;
    ya:=0;
    while (j>=0) do begin
          if xa>ya then
             if a[j]>0 then begin
                inc(ya);
                c[ya]:=a[j];
                p[ya]:=j;
                fo:=0;
                ffo:=0;
                inc(j,t);
                continue;
                end;
          if xa<=ya then begin
             inc(fo);
             if fo>valori[t] then
                begin
                inc(xa);
                if xa<=ya then begin
                   fo:=fo-d[xa];
                   ffo:=ffo-d[xa];
                   end;
                end;
             end;
          if xa<=ya then begin
             if a[j]=0
                then a[j]:=fo+c[ya]
                else begin
                     while (xa<=ya) and (a[j]<c[ya]+fo-ffo) do begin
                           ffo:=ffo-d[ya];
                           dec(ya);
                           end;
                     if ya<xa then begin
                        c[xa]:=a[j];
                        p[xa]:=j;
                        fo:=0;
                        ffo:=0;
                        ya:=xa;
                        end
                        else begin
                        inc(ya);
                        p[ya]:=j;
                        d[ya]:=(j-p[ya-1]) div t;
                        c[ya]:=a[j];
                        ffo:=ffo+d[ya];
                        end;
                     if a[j]>c[xa]+fo then a[j]:=c[xa]+fo;
                     end;
             end;
          inc(j,t);
          end;
    end;
end;

procedure afis;
var aa,bb:word;
begin
if odd(inf+sup) then begin
   aa:=(inf+sup) div 2;
   bb:=aa+1;
   end
   else begin
   aa:=(inf+sup) div 2;
   bb:=aa;
   end;
while (a[aa]=0) and (a[bb]=0) do
      begin
      dec(aa);
      inc(bb);
      end;
if (a[aa]=0) or (a[aa]>a[bb])
   then writeln(a[aa]-1)
   else writeln(a[bb]-1);
end;

begin
assign(input,'dom.in');
reset(input);
assign(output,'dom.out');
rewrite(output);
citire;
for i:=6 downto 1 do obtp(i);
for i:=-6 to -1 do obtn(i);
afis;
end.
---------------------------
